home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / MARKS.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  3.0 KB  |  84 lines
  1. ;;;; Permanent Marks
  2.  
  3. ;;; The marks list is cleaned every time that a mark is added to the list,
  4. ;;; and every time that FOR-EACH-MARK! is called.  This should keep the
  5. ;;; number of extraneous entries to a minimum.  Note that FOR-EACH-MARK!
  6. ;;; and SET-MARK-LINE! are intended to be used together; in particular,
  7. ;;; a great deal of cleverness has been used to ensure that the changes
  8. ;;; made by SET-MARK-LINE! are noticed by FOR-EACH-MARK!.  This turned out
  9. ;;; to be non-trivial to implement.
  10.  
  11. (define (mark-permanent! mark)
  12.   (let ((n (object-hash mark))
  13.     (marks (line-marks (mark-line mark))))
  14.     (if (not (memv n marks))
  15.     (let ((marks (cons n marks)))
  16.       (begin (clean-marks-tail! marks)
  17.          (set-line-marks! (mark-line mark) marks)))))
  18.   mark)
  19.  
  20. (define (clean-marks-tail! marks)
  21.   (if (not (null? (cdr marks)))
  22.       (if (object-unhash (cadr marks))
  23.       (clean-marks-tail! (cdr marks))
  24.       (begin (set-cdr! marks (cddr marks))
  25.          (clean-marks-tail! marks)))))
  26.  
  27. (define (for-each-mark! line procedure)
  28.   (define (loop-1 marks)
  29.     (if (not (null? marks))
  30.     (let ((mark (object-unhash (car marks))))
  31.       (if mark
  32.           (begin (procedure mark #F)
  33.              (if (eq? marks (line-marks line))
  34.              (loop-2 marks (cdr marks))
  35.              (loop-1 (line-marks line))))
  36.           (begin (set-line-marks! line (cdr marks))
  37.              (loop-1 (line-marks line)))))))
  38.   (define (loop-2 previous marks)
  39.     (if (not (null? marks))
  40.     (let ((mark (object-unhash (car marks))))
  41.       (if mark
  42.           (begin (procedure mark #F)
  43.              (if (eq? marks (cdr previous))
  44.              (loop-2 marks (cdr marks))
  45.              (loop-2 previous (cdr previous))))
  46.           (begin (set-cdr! previous (cddr previous))
  47.              (loop-2 previous (cdr previous)))))))
  48.  
  49. ;;; point is treated as a special case and is no longer a permanent mark
  50. ;;; This would decrease the number of permanent marks considerably.
  51. ;;; Permannet marks are not so cheap and should be used only when
  52. ;;; really needed. Currently the point is obtained from current point
  53. ;;; but in a general setting there should be a way to get back to the
  54. ;;; buffer from group to get  the point.
  55.  
  56.   (let ((point (current-point)))
  57.     (if (and (eq? line (mark-line point))
  58.              (let ((n (object-hash point)))
  59.                (not (memv n (line-marks line)))))
  60.         (procedure point #T)))
  61.   (loop-1 (line-marks line)))
  62.  
  63. (define (set-mark-line! mark new-line)
  64.   (let ((old-line (mark-line mark)))
  65.     (cond ((not (eq? old-line new-line))
  66.        (let ((marks
  67.           (let ((n (object-hash mark))
  68.             (marks (line-marks old-line)))
  69.             (define (loop previous marks)
  70.               (if (= n (car marks))
  71.               (begin (set-cdr! previous (cdr marks))
  72.                  marks)
  73.               (loop marks (cdr marks))))
  74.             (if (= n (car marks))
  75.             (begin (set-line-marks! old-line (cdr marks))
  76.                    marks)
  77.             (loop marks (cdr marks))))))
  78.          (%set-mark-line! mark new-line)
  79.          (set-cdr! marks (line-marks new-line))
  80.          (clean-marks-tail! marks)
  81.          (set-line-marks! new-line marks))))))
  82.  
  83.  
  84.